perm filename PERMS.LSP[NBS,WD] blob
sn#235042 filedate 1976-08-27 generic text, type C, neo UTF8
COMMENT ā VALID 00007 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00002 00002 (DECLARE (SETQ BASE (SETQ IBASE 10.)))
C00006 00003 (DE EXCEPT1 (LST MIN MAX)
C00011 00004 (DE POSIT (NUM LST)
C00014 00005 (SETQ KEYMAP @
C00017 00006 (SETQ S1 (LIST (SETQ S11 (QUOTE (14 4 13 1 2 15 11 8 3 10 6 12 5 9 0 7)))
C00021 00007 (DE PERMS (L)
C00023 ENDMK
Cā;
(DECLARE (SETQ BASE (SETQ IBASE 10.)))
(SETQ BASE (SETQ IBASE 10.))
(SETQ *NOPOINT T)
(DE BITPATH (SH PC1 PC2 BIT SCALE)
(PROG (CNT)
(PRINC (READLIST (CONS (QUOTE B) (EXPLODE BIT))))
(PRINC @ / )
(SETQ CNT 0)
LOOP (COND ((NULL SH) (PRINC @ / ) (PRINTNUMBER CNT BASE SCALE) (RETURN NIL)))
(SETQ PC1 (LIST (ROT (CAR SH) (CAR PC1)) (ROT (CAR SH) (CADR PC1))))
(SETQ POS (POSIT BIT (CHOICE PC2 (APPEND (CAR PC1) (CADR PC1)))))
(COND ((NULL POS) (PRINC @ / ) (PRINC @ / ))
(T (PRINTNUMBER POS BASE SCALE)
(SETQ CNT (ADD1 CNT))))
(PRINC @ / ) (PRINC @ / )
(SETQ SH (CDR SH))
(GO LOOP)))
(DE BITPATHS (SH PC1 PC2)
(PROG (CNT LIM)
(SETQ CNT (MINIMUM (APPEND (CAR PC1) (CADR PC1))))
(SETQ LIM (MAXIMUM (APPEND (CAR PC1) (CADR PC1))))
LOOP (COND ((GREATERP CNT LIM) (RETURN NIL)))
(BITPATH SH PC1 PC2 CNT LIM)
(TERPRI) (TERPRI)
(SETQ CNT (ADD1 CNT))
(GO LOOP)))
(DEFPROP CHECKIT
(LAMBDA (MIN MAX L)
(PROG (ANS ELT MULT)
(SETQ ELT MIN)
LOOP (COND ((GREATERP ELT MAX) (RETURN (REVERSE ANS))))
(SETQ MULT (COUNTEM ELT L))
(COND ((NOT (EQ MULT 1))
(SETQ ANS (CONS (CONS ELT MULT) ANS))))
(SETQ ELT (ADD1 ELT))
(GO LOOP)))
EXPR)
(DE CHOICE (PC L)
(PROG (RES)
LOOP (COND ((NULL PC) (RETURN (REVERSE RES))))
(SETQ RES (CONS (NTH (CAR PC) L) RES))
(SETQ PC (CDR PC))
(GO LOOP)))
(DE COLUMNPRINT (WDTH LST)
(PROG (CNT)
LOOP(SETQ CNT 0)
(TERPRI)
ILOOP(COND ((NULL LST) (TERPRI) (TERPRI) (RETURN NIL)))
(COND ((EQUAL CNT WDTH) (GO LOOP)))
(PRINC @ / )
(PRINTNUMBER (CAR LST) 10 99)
(SETQ LST (CDR LST))
(SETQ CNT (ADD1 CNT))
(GO ILOOP)))
(DE COUNTEM (N L)
(PROG NIL
(SETQ M 0)
LOOP (COND ((NULL L) (RETURN M)))
(COND ((EQ (CAR L) N) (SETQ M (ADD1 M))))
(SETQ L (CDR L))
(GO LOOP)))
(DE EXCEPT (SH PC1 PC2 MIN MAX)
(PROG (CNT)
(SETQ CNT 0)
LOOP (COND ((NULL SH) (RETURN NIL)))
(SETQ CNT (ADD1 CNT))
(SETQ PC1 (LIST (ROT (CAR SH) (CAR PC1)) (ROT (CAR SH) (CADR PC1))))
(PRINC (READLIST (CONS (QUOTE E) (EXPLODE CNT))))
(PRINC @ / )
(PRINTLIST (EXCEPT1 (CHOICE PC2 (APPEND (CAR PC1) (CADR PC1))) MIN MAX))
(TERPRI)
(SETQ SH (CDR SH))
(GO LOOP)))
(DE EXCEPT1 (LST MIN MAX)
(PROG (CNT EXC)
(SETQ CNT MIN)
LOOP (COND ((GREATERP CNT MAX) (RETURN (REVERSE EXC))))
(COND ((NOT (MEMBER CNT LST)) (SETQ EXC (CONS CNT EXC))))
(SETQ CNT (ADD1 CNT))
(GO LOOP)))
(DE IB (S)
(PROG (CNT INCR POS SQSUM SS)
(SETQ SQSUM 0)
(SETQ INCR 0)
LOOP (COND ((GREATERP INCR (LENGTH S)) (RETURN SQSUM)))
(SETQ SS S)
(SETQ POS 0)
(SETQ CNT 0)
ILOOP(COND ((NULL SS) (GO ELOOP)))
(COND ((EQ (CAR SS) (XOR POS INCR)) (SETQ CNT (ADD1 CNT))))
(SETQ SS (CDR SS))
(SETQ POS (ADD1 POS))
(GO ILOOP)
ELOOP(SETQ SQSUM (PLUS SQSUM (SQUARE CNT)))
(SETQ INCR (ADD1 INCR))
(GO LOOP)))
(DF IB4 (S)
(PROG (CNT VS)
(SETQ CNT 1)
(SETQ VS (EVAL (CAR S)))
LOOP (COND ((NULL VS) (TERPRI) (RETURN NIL)))
(PRINC @ / )
(PRINC (READLIST (APPEND (EXPLODE (CAR S)) (LIST CNT))))
(PRINC @ / =/ )
(PRINC (IB (CAR VS)))
(SETQ VS (CDR VS))
(SETQ CNT (ADD1 CNT))
(GO LOOP)))
(COMMENT IBA IS IN ERROR THE MULTIPLIER MUST BE A NONSINGULAR 4 BY 4 MATRIX)
(DE IBA (S)
(PROG (CNT INCR1 INCR2 POS SQSUM SS)
(SETQ SQSUM 0)
(SETQ INCR1 0)
LOOP1(COND ((GREATERP INCR1 (LENGTH S)) (RETURN SQSUM)))
(SETQ INCR2 0)
LOOP2(COND ((GREATERP INCR2 (LENGTH S)) (SETQ INCR1 (ADD1 INCR1))
(GO LOOP1)))
(SETQ SS S)
(SETQ POS 0)
(SETQ CNT 0)
ILOOP(COND ((NULL SS) (SETQ SQSUM (PLUS SQSUM (SQUARE CNT)))
(SETQ INCR2 (ADD1 INCR2))
(GO LOOP2)))
(COND ((EQ (CAR SS) (XOR (BOOLE 1 POS INCR1) INCR2)) (SETQ CNT (ADD1 CNT))))
(SETQ SS (CDR SS))
(SETQ POS (ADD1 POS))
(GO ILOOP)))
(DF IBA4 (S)
(PROG (CNT VS)
(SETQ CNT 1)
(SETQ VS (EVAL (CAR S)))
LOOP (COND ((NULL VS) (TERPRI) (RETURN NIL)))
(PRINC @ / )
(PRINC (READLIST (APPEND (EXPLODE (CAR S)) (LIST CNT))))
(PRINC @ / =/ )
(PRINC (IBA (CAR VS)))
(SETQ VS (CDR VS))
(SETQ CNT (ADD1 CNT))
(GO LOOP)))
(DE KEYSCH (SH PC1 PC2 WIDTH)
(PROG (CNT)
(SETQ CNT 0)
LOOP (COND ((NULL SH) (RETURN NIL)))
(SETQ CNT (ADD1 CNT))
(SETQ PC1 (LIST (ROT (CAR SH) (CAR PC1)) (ROT (CAR SH) (CADR PC1))))
(PRINC (QUOTE / / / / / / / ))
(PRINC (READLIST (CONS (QUOTE K) (EXPLODE CNT))))
(TERPRI)
(COLUMNPRINT WIDTH (CHOICE PC2 (APPEND (CAR PC1) (CADR PC1))))
(TERPRI)
(SETQ SH (CDR SH))
(GO LOOP)))
(DE MAXIMUM (L)
(PROG (MOST)
LOOP (COND ((NULL L) (RETURN MOST)))
(COND ((NOT (GREATERP MOST (CAR L))) (SETQ MOST (CAR L))))
(SETQ L (CDR L))
(GO LOOP)))
(DE MINIMUM (L)
(PROG (LEAST)
LOOP (COND ((NULL L) (RETURN LEAST)))
(COND ((NOT (GREATERP (CAR L) LEAST)) (SETQ LEAST (CAR L))))
(SETQ L (CDR L))
(GO LOOP)))
(DE NTH (N L)
(PROG NIL
LOOP (COND ((EQ N 1) (RETURN (CAR L))))
(SETQ N (SUB1 N))
(SETQ L (CDR L))
(GO LOOP)))
(DE PRINTLIST (LST)
(PROG NIL
LOOP (COND ((NULL LST) (RETURN NIL)))
(PRINC (CAR LST))
(PRINC @ / )
(SETQ LST (CDR LST))
(GO LOOP)))
(DE PRINCSP (NUM)
(PROG NIL
LOOP (COND ((ZEROP NUM) (RETURN NIL)))
(PRINC (QUOTE / ))
(SETQ NUM (SUB1 NUM))
(GO LOOP)))
(DE POSIT (NUM LST)
(PROG (CNT)
(SETQ CNT 1)
LOOP (COND ((NULL LST) (RETURN NIL)))
(COND ((EQ (CAR LST) NUM) (RETURN CNT)))
(SETQ CNT (ADD1 CNT))
(SETQ LST (CDR LST))
(GO LOOP)))
(DE PRINTNUMBER (NUMBER RADIX SCALE)
(PROG (BASE)
(SETQ BASE RADIX)
(PRINCSP (*DIF (FLATSIZE SCALE) (FLATSIZE NUMBER)))
(PRINC NUMBER)))
(DE ROT (N L)
(PROG NIL
LOOP (COND ((ZEROP N) (RETURN L)))
(SETQ N (SUB1 N))
(SETQ L (APPEND (CDR L) (LIST (CAR L))))
(GO LOOP)))
(DE SFLAT (SBOX)
(PROG (N ANS BASE IBASE)
(SETQ N 0)
(SETQ BASE (SETQ IBASE 2))
LOOP (COND ((GREATERP N 63) (RETURN (REVERSE ANS))))
(SETQ ANS (CONS (SLOOK N SBOX) ANS))
(SETQ N (ADD1 N))
(GO LOOP)))
(DE SLOOK (NUM SBOX)
(PROG (A D EN I J BASE IBASE)
(SETQ BASE (SETQ IBASE 2))
(SETQ EN (CDR (EXPLODE (PLUS NUM 64))))
(SETQ A (CAR EN))
(SETQ D (REVERSE (CDR EN)))
(SETQ I (READLIST (LIST A (CAR D))))
(SETQ J (READLIST (REVERSE (CDR D))))
(RETURN (SLOOK1 I J SBOX))))
(DE SLOOK1 (I J SBOX) (NTH (ADD1 J) (NTH (ADD1 I) SBOX)))
(DE SQUARE (X) (TIMES X X))
(DE XOR (A B) (BOOLE 6 A B))
(SETQ KEYMAP @
(1 2 3 4 5 6 7 P
8 9 10 11 12 13 14 P
15 16 17 18 19 20 21 P
22 23 24 25 26 27 28 P
29 30 31 32 33 34 35 P
36 37 38 39 40 41 42 P
43 44 45 46 47 48 49 P
50 51 52 53 54 55 56 P))
(SETQ PC164
(LIST (SETQ PC164C @ (57 49 41 33 25 17 9 1
58 50 42 34 26 18 10 2
59 51 43 35 27 19 11 3
60 52 44 36))
(SETQ PC164D @ (63 55 47 39 31 23 15 7
62 54 46 38 30 22 14 6
61 53 45 37 29 21 13 5
28 20 12 4))))
(SETQ ID056 @ (( 0 1 2 3 4 5 6
7 8 9 10 11 12 13
14 15 16 17 18 19 20
21 22 23 24 25 26 27)
(28 29 30 31 32 33 34
35 36 37 38 39 40 41
42 43 44 45 46 47 48
49 50 51 52 53 54 55)))
(SETQ PC156 (LIST (SETQ PC156C (CHOICE PC164C KEYMAP))
(SETQ PC156D (CHOICE PC164D KEYMAP))))
(SETQ PC248
(APPEND (SETQ PC248C @ (14 17 11 24 1 5
3 28 15 6 21 10
23 19 12 4 26 8
16 7 27 20 13 2))
(SETQ PC248D @ (41 52 31 37 47 55
30 40 51 45 33 48
44 49 39 56 34 53
46 42 50 36 29 32))))
(SETQ PC216
(APPEND
(SETQ PC216C @ (14 5 3 10 23 8 16 2))
(SETQ PC216D @ (41 55 30 48 44 53 46 32))))
(SETQ PC232
(APPEND
(SETQ PC248C @ (17 11 24 1 28 15 6 21
19 12 4 26 7 27 20 13))
(SETQ PC248D @ (52 31 37 47 40 51 45 33
49 39 56 34 42 50 36 29))))
(SETQ SHIFTS @ (1 1 2 2 2 2 2 2 1 2 2 2 2 2 2 1))
(SETQ S1 (LIST (SETQ S11 (QUOTE (14 4 13 1 2 15 11 8 3 10 6 12 5 9 0 7)))
(SETQ S12 (QUOTE (0 15 7 4 14 2 13 1 10 6 12 11 9 5 3 8)))
(SETQ S13 (QUOTE (4 1 14 8 13 6 2 11 15 12 9 7 3 10 5 0)))
(SETQ S14 (QUOTE (15 12 8 2 4 9 1 7 5 11 3 14 10 0 6 13)))))
(SETQ S2 (LIST (SETQ S21 (QUOTE (15 1 8 14 6 11 3 4 9 7 2 13 12 0 5 10)))
(SETQ S22 (QUOTE (3 13 4 7 15 2 8 14 12 0 1 10 6 9 11 5)))
(SETQ S23 (QUOTE (0 14 7 11 10 4 13 1 5 8 12 6 9 3 2 15)))
(SETQ S24 (QUOTE (13 8 10 1 3 15 4 2 11 6 7 12 0 5 14 9)))))
(SETQ S3 (LIST (SETQ S31 (QUOTE (10 0 9 14 6 3 15 5 1 13 12 7 11 4 2 8)))
(SETQ S32 (QUOTE (13 7 0 9 3 4 6 10 2 8 5 14 12 11 15 1)))
(SETQ S33 (QUOTE (13 6 4 9 8 15 3 0 11 1 2 12 5 10 14 7)))
(SETQ S34 (QUOTE (1 10 13 0 6 9 8 7 4 15 14 3 11 5 2 12)))))
(SETQ S4 (LIST (SETQ S41 (QUOTE (7 13 14 3 0 6 9 10 1 2 8 5 11 12 4 15)))
(SETQ S42 (QUOTE (13 8 11 5 6 15 0 3 4 7 2 12 1 10 14 9)))
(SETQ S43 (QUOTE (10 6 9 0 12 11 7 13 15 1 3 14 5 2 8 4)))
(SETQ S44 (QUOTE (3 15 0 6 10 1 13 8 9 4 5 11 12 7 2 14)))))
(SETQ S5 (LIST (SETQ S51 (QUOTE (2 12 4 1 7 10 11 6 8 5 3 15 13 0 14 9)))
(SETQ S52 (QUOTE (14 11 2 12 4 7 13 1 5 0 15 10 3 9 8 6)))
(SETQ S53 (QUOTE (4 2 1 11 10 13 7 8 15 9 12 5 6 3 0 14)))
(SETQ S54 (QUOTE (11 8 12 7 1 14 2 13 6 15 0 9 10 4 5 3)))))
(SETQ S6 (LIST (SETQ S61 (QUOTE (12 1 10 15 9 2 6 8 0 13 3 4 14 7 5 11)))
(SETQ S62 (QUOTE (10 15 4 2 7 12 9 5 6 1 13 14 0 11 3 8)))
(SETQ S63 (QUOTE (9 14 15 5 2 8 12 3 7 0 4 10 1 13 11 6)))
(SETQ S64 (QUOTE (4 3 2 12 9 5 15 10 11 14 1 7 6 0 8 13)))))
(SETQ S7 (LIST (SETQ S71 (QUOTE (4 11 2 14 15 0 8 13 3 12 9 7 5 10 6 1)))
(SETQ S72 (QUOTE (13 0 11 7 4 9 1 10 14 3 5 12 2 15 8 6)))
(SETQ S73 (QUOTE (1 4 11 13 12 3 7 14 10 15 6 8 0 5 9 2)))
(SETQ S74 (QUOTE (6 11 13 8 1 4 10 7 9 5 0 15 14 2 3 12)))))
(SETQ S8 (LIST (SETQ S81 (QUOTE (13 2 8 4 6 15 11 1 10 9 3 14 5 0 12 7)))
(SETQ S82 (QUOTE (1 15 13 8 10 3 7 4 12 5 6 11 0 14 9 2)))
(SETQ S83 (QUOTE (7 11 4 1 9 12 14 2 0 6 10 13 15 3 5 8)))
(SETQ S84 (QUOTE (2 1 14 7 4 10 8 13 15 12 9 0 3 5 6 11)))))
(DE PERMS (L)
(COND ((NULL L) (LIST NIL)) (T (RUNTHRU (CAR L) (PERMS (CDR L))))))
(DE RUNTHRU (E L)
(PROG (ANS)
LOOP (COND ((NULL L) (RETURN ANS)))
(SETQ ANS (APPEND ANS (RUNTHRU1 E (CAR L))))
(SETQ L (CDR L))
(GO LOOP)))
(DE RUNTHRU1 (E L)
(PROG (FRONT BACK ANS)
(SETQ BACK L)
LOOP (SETQ ANS (CONS (APPEND FRONT (LIST E) BACK) ANS))
(COND ((NULL BACK) (RETURN (REVERSE ANS))))
(SETQ FRONT (APPEND FRONT (LIST (CAR BACK))))
(SETQ BACK (CDR BACK))
(GO LOOP)))
(DE PRINL (L) (MAPC (FUNCTION PRINC) L))
(DE NTHCDR (N L) (COND ((ZEROP N) L) (T (NTHCDR (SUB1 N) (CDR L)))))
(DE PROD (P Q)
(PROG (PROD)
LOOP (COND ((NULL P) (RETURN (REVERSE PROD))))
(SETQ PROD (CONS (CAR (NTHCDR (SUB1 (CAR P)) Q)) PROD))
(SETQ P (CDR P))
(GO LOOP)))
(DE LISTSQUARES (L)
(PROG (PS SQ)
(SETQ PS (PERMS L))
LOOP (COND ((NULL PS) (RETURN NIL)))
(PRINL (CAR PS))
(PRINC (QUOTE / / / ))
(SETQ SQ (PROD (CAR PS) (CAR PS)))
(COND ((NOT (EQUAL SQ L)) (PRINC (QUOTE / / ))))
(PRINL SQ)
(TERPRI)
(SETQ PS (CDR PS))
(GO LOOP)))